home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _d17425d8c4caebb80528cb77a3282c56 < prev    next >
Encoding:
Text File  |  2002-05-01  |  21.7 KB  |  805 lines
  1. package HTTP::Cookies;
  2.  
  3. use strict;
  4. use HTTP::Date qw(str2time time2str);
  5. use HTTP::Headers::Util qw(split_header_words join_header_words);
  6. use LWP::Debug ();
  7.  
  8. use vars qw($VERSION);
  9. $VERSION = sprintf("%d.%02d", q$Revision: 1.24 $ =~ /(\d+)\.(\d+)/);
  10.  
  11. my $EPOCH_OFFSET = 0;  # difference from Unix epoch
  12. if ($^O eq "MacOS") {
  13.     require Time::Local;
  14.     $EPOCH_OFFSET = Time::Local::timelocal(0,0,0,1,0,70);
  15. }
  16.  
  17. =head1 NAME
  18.  
  19. HTTP::Cookies - Cookie storage and management
  20.  
  21. =head1 SYNOPSIS
  22.  
  23.  use HTTP::Cookies;
  24.  $cookie_jar = HTTP::Cookies->new;
  25.  
  26.  $cookie_jar->add_cookie_header($request);
  27.  $cookie_jar->extract_cookies($response);
  28.  
  29. =head1 DESCRIPTION
  30.  
  31. Cookies are a general mechanism which server side connections can use
  32. to both store and retrieve information on the client side of the
  33. connection.  For more information about cookies refer to
  34. <URL:http://www.netscape.com/newsref/std/cookie_spec.html> and
  35. <URL:http://www.cookiecentral.com/>.  This module also implements the
  36. new style cookies described in I<RFC 2965>.
  37. The two variants of cookies are supposed to be able to coexist happily.
  38.  
  39. Instances of the class I<HTTP::Cookies> are able to store a collection
  40. of Set-Cookie2: and Set-Cookie: headers and are able to use this
  41. information to initialize Cookie-headers in I<HTTP::Request> objects.
  42. The state of a I<HTTP::Cookies> object can be saved in and restored from
  43. files.
  44.  
  45. =head1 METHODS
  46.  
  47. The following methods are provided:
  48.  
  49. =over 4
  50.  
  51. =cut
  52.  
  53. # A HTTP::Cookies object is a hash.  The main attribute is the
  54. # COOKIES 3 level hash:  $self->{COOKIES}{$domain}{$path}{$key}.
  55.  
  56.  
  57. =item $cookie_jar = HTTP::Cookies->new;
  58.  
  59. The constructor takes hash style parameters.  The following
  60. parameters are recognized:
  61.  
  62.   file:            name of the file to restore cookies from and save cookies to
  63.   autosave:        save during destruction (bool)
  64.   ignore_discard:  save even cookies that are requested to be discarded (bool)
  65.   hide_cookie2:    don't add Cookie2 header to requests
  66.  
  67. Future parameters might include (not yet implemented):
  68.  
  69.   max_cookies               300
  70.   max_cookies_per_domain    20
  71.   max_cookie_size           4096
  72.  
  73.   no_cookies   list of domain names that we never return cookies to
  74.  
  75. =cut
  76.  
  77. sub new
  78. {
  79.     my $class = shift;
  80.     my $self = bless {
  81.     COOKIES => {},
  82.     }, $class;
  83.     my %cnf = @_;
  84.     for (keys %cnf) {
  85.     $self->{lc($_)} = $cnf{$_};
  86.     }
  87.     $self->load;
  88.     $self;
  89. }
  90.  
  91.  
  92. =item $cookie_jar->add_cookie_header($request);
  93.  
  94. The add_cookie_header() method will set the appropriate Cookie:-header
  95. for the I<HTTP::Request> object given as argument.  The $request must
  96. have a valid url attribute before this method is called.
  97.  
  98. =cut
  99.  
  100. sub add_cookie_header
  101. {
  102.     my $self = shift;
  103.     my $request = shift || return;
  104.     my $url = $request->url;
  105.     my $domain = _host($request, $url);
  106.     $domain = "$domain.local" unless $domain =~ /\./;
  107.     my $secure_request = ($url->scheme eq "https");
  108.     my $req_path = _url_path($url);
  109.     my $req_port = $url->port;
  110.     my $now = time();
  111.     _normalize_path($req_path) if $req_path =~ /%/;
  112.  
  113.     my @cval;    # cookie values for the "Cookie" header
  114.     my $set_ver;
  115.     my $netscape_only = 0; # An exact domain match applies to any cookie
  116.  
  117.     while ($domain =~ /\./) {
  118.  
  119.         LWP::Debug::debug("Checking $domain for cookies");
  120.     my $cookies = $self->{COOKIES}{$domain};
  121.     next unless $cookies;
  122.  
  123.     # Want to add cookies corresponding to the most specific paths
  124.     # first (i.e. longest path first)
  125.     my $path;
  126.     for $path (sort {length($b) <=> length($a) } keys %$cookies) {
  127.             LWP::Debug::debug("- checking cookie path=$path");
  128.         if (index($req_path, $path) != 0) {
  129.             LWP::Debug::debug("  path $path:$req_path does not fit");
  130.         next;
  131.         }
  132.  
  133.         my($key,$array);
  134.         while (($key,$array) = each %{$cookies->{$path}}) {
  135.         my($version,$val,$port,$path_spec,$secure,$expires) = @$array;
  136.             LWP::Debug::debug(" - checking cookie $key=$val");
  137.         if ($secure && !$secure_request) {
  138.             LWP::Debug::debug("   not a secure requests");
  139.             next;
  140.         }
  141.         if ($expires && $expires < $now) {
  142.             LWP::Debug::debug("   expired");
  143.             next;
  144.         }
  145.         if ($port) {
  146.             my $found;
  147.             if ($port =~ s/^_//) {
  148.             # The correponding Set-Cookie attribute was empty
  149.             $found++ if $port eq $req_port;
  150.             $port = "";
  151.             } else {
  152.             my $p;
  153.             for $p (split(/,/, $port)) {
  154.                 $found++, last if $p eq $req_port;
  155.             }
  156.             }
  157.             unless ($found) {
  158.                 LWP::Debug::debug("   port $port:$req_port does not fit");
  159.             next;
  160.             }
  161.         }
  162.         if ($version > 0 && $netscape_only) {
  163.             LWP::Debug::debug("   domain $domain applies to " .
  164.                       "Netscape-style cookies only");
  165.             next;
  166.         }
  167.  
  168.             LWP::Debug::debug("   it's a match");
  169.  
  170.         # set version number of cookie header.
  171.             # XXX: What should it be if multiple matching
  172.                 #      Set-Cookie headers have different versions themselves
  173.         if (!$set_ver++) {
  174.             if ($version >= 1) {
  175.             push(@cval, "\$Version=$version");
  176.             } elsif (!$self->{hide_cookie2}) {
  177.             $request->header(Cookie2 => '$Version="1"');
  178.             }
  179.         }
  180.  
  181.         # do we need to quote the value
  182.         if ($val =~ /\W/ && $version) {
  183.             $val =~ s/([\\\"])/\\$1/g;
  184.             $val = qq("$val");
  185.         }
  186.  
  187.         # and finally remember this cookie
  188.         push(@cval, "$key=$val");
  189.         if ($version >= 1) {
  190.             push(@cval, qq(\$Path="$path"))     if $path_spec;
  191.             push(@cval, qq(\$Domain="$domain")) if $domain =~ /^\./;
  192.             if (defined $port) {
  193.             my $p = '$Port';
  194.             $p .= qq(="$port") if length $port;
  195.             push(@cval, $p);
  196.             }
  197.         }
  198.  
  199.         }
  200.         }
  201.  
  202.     } continue {
  203.     # Try with a more general domain, alternately stripping
  204.     # leading name components and leading dots.  When this
  205.     # results in a domain with no leading dot, it is for
  206.     # Netscape cookie compatibility only:
  207.     #
  208.     # a.b.c.net    Any cookie
  209.     # .b.c.net    Any cookie
  210.     # b.c.net    Netscape cookie only
  211.     # .c.net    Any cookie
  212.  
  213.     if ($domain =~ s/^\.+//) {
  214.         $netscape_only = 1;
  215.     } else {
  216.         $domain =~ s/[^.]*//;
  217.         $netscape_only = 0;
  218.     }
  219.     }
  220.  
  221.     $request->header(Cookie => join("; ", @cval)) if @cval;
  222.  
  223.     $request;
  224. }
  225.  
  226.  
  227. =item $cookie_jar->extract_cookies($response);
  228.  
  229. The extract_cookies() method will look for Set-Cookie: and
  230. Set-Cookie2: headers in the I<HTTP::Response> object passed as
  231. argument.  Any of these headers that are found are used to update
  232. the state of the $cookie_jar.
  233.  
  234. =cut
  235.  
  236. sub extract_cookies
  237. {
  238.     my $self = shift;
  239.     my $response = shift || return;
  240.  
  241.     my @set = split_header_words($response->_header("Set-Cookie2"));
  242.     my @ns_set = $response->_header("Set-Cookie");
  243.  
  244.     return $response unless @set || @ns_set;  # quick exit
  245.  
  246.     my $request = $response->request;
  247.     my $url = $request->url;
  248.     my $req_host = _host($request, $url);
  249.     $req_host = "$req_host.local" unless $req_host =~ /\./;
  250.     my $req_port = $url->port;
  251.     my $req_path = _url_path($url);
  252.     _normalize_path($req_path) if $req_path =~ /%/;
  253.  
  254.     if (@ns_set) {
  255.     # The old Netscape cookie format for Set-Cookie
  256.         # http://www.netscape.com/newsref/std/cookie_spec.html
  257.     # can for instance contain an unquoted "," in the expires
  258.     # field, so we have to use this ad-hoc parser.
  259.     my $now = time();
  260.  
  261.     # Build a hash of cookies that was present in Set-Cookie2
  262.     # headers.  We need to skip them if we also find them in a
  263.     # Set-Cookie header.
  264.     my %in_set2;
  265.     for (@set) {
  266.         $in_set2{$_->[0]}++;
  267.     }
  268.  
  269.     my $set;
  270.     for $set (@ns_set) {
  271.         my @cur;
  272.         my $param;
  273.         my $expires;
  274.         for $param (split(/;\s*/, $set)) {
  275.         my($k,$v) = split(/\s*=\s*/, $param, 2);
  276.         $v =~ s/\s+$//;
  277.         #print "$k => $v\n";
  278.         my $lc = lc($k);
  279.         if ($lc eq "expires") {
  280.             my $etime = str2time($v);
  281.             if ($etime) {
  282.             push(@cur, "Max-Age" => str2time($v) - $now);
  283.             $expires++;
  284.             }
  285.         } else {
  286.             push(@cur, $k => $v);
  287.         }
  288.         }
  289.         next if $in_set2{$cur[0]};
  290.  
  291. #        push(@cur, "Port" => $req_port);
  292.         push(@cur, "Discard" => undef) unless $expires;
  293.         push(@cur, "Version" => 0);
  294.         push(@cur, "ns-cookie" => 1);
  295.         push(@set, \@cur);
  296.     }
  297.     }
  298.  
  299.   SET_COOKIE:
  300.     for my $set (@set) {
  301.     next unless @$set >= 2;
  302.  
  303.     my $key = shift @$set;
  304.     my $val = shift @$set;
  305.  
  306.         LWP::Debug::debug("Set cookie $key => $val");
  307.  
  308.     my %hash;
  309.     while (@$set) {
  310.         my $k = shift @$set;
  311.         my $v = shift @$set;
  312.         my $lc = lc($k);
  313.         # don't loose case distinction for unknown fields
  314.         $k = $lc if $lc =~ /^(?:discard|domain|max-age|
  315.                                     path|port|secure|version)$/x;
  316.         if ($k eq "discard" || $k eq "secure") {
  317.         $v = 1 unless defined $v;
  318.         }
  319.         next if exists $hash{$k};  # only first value is signigicant
  320.         $hash{$k} = $v;
  321.     };
  322.  
  323.     my %orig_hash = %hash;
  324.     my $version   = delete $hash{version};
  325.     $version = 1 unless defined($version);
  326.     my $discard   = delete $hash{discard};
  327.     my $secure    = delete $hash{secure};
  328.     my $maxage    = delete $hash{'max-age'};
  329.     my $ns_cookie = delete $hash{'ns-cookie'};
  330.  
  331.     # Check domain
  332.     my $domain  = delete $hash{domain};
  333.     if (defined($domain)
  334.         && $domain ne $req_host && $domain ne ".$req_host") {
  335.         if ($domain !~ /\./ && $domain ne "local") {
  336.             LWP::Debug::debug("Domain $domain contains no dot");
  337.         next SET_COOKIE;
  338.         }
  339.         $domain = ".$domain" unless $domain =~ /^\./;
  340.         if ($domain =~ /\.\d+$/) {
  341.             LWP::Debug::debug("IP-address $domain illeagal as domain");
  342.         next SET_COOKIE;
  343.         }
  344.         my $len = length($domain);
  345.         unless (substr($req_host, -$len) eq $domain) {
  346.             LWP::Debug::debug("Domain $domain does not match host $req_host");
  347.         next SET_COOKIE;
  348.         }
  349.         my $hostpre = substr($req_host, 0, length($req_host) - $len);
  350.         if ($hostpre =~ /\./ && !$ns_cookie) {
  351.             LWP::Debug::debug("Host prefix contain a dot: $hostpre => $domain");
  352.         next SET_COOKIE;
  353.         }
  354.     } else {
  355.         $domain = $req_host;
  356.     }
  357.  
  358.     my $path = delete $hash{path};
  359.     my $path_spec;
  360.     if (defined $path && $path ne '') {
  361.         $path_spec++;
  362.         _normalize_path($path) if $path =~ /%/;
  363.         if (!$ns_cookie &&
  364.                 substr($req_path, 0, length($path)) ne $path) {
  365.             LWP::Debug::debug("Path $path is not a prefix of $req_path");
  366.         next SET_COOKIE;
  367.         }
  368.     } else {
  369.         $path = $req_path;
  370.         $path =~ s,/[^/]*$,,;
  371.         $path = "/" unless length($path);
  372.     }
  373.  
  374.     my $port;
  375.     if (exists $hash{port}) {
  376.         $port = delete $hash{port};
  377.         if (defined $port) {
  378.         $port =~ s/\s+//g;
  379.         my $found;
  380.         for my $p (split(/,/, $port)) {
  381.             unless ($p =~ /^\d+$/) {
  382.               LWP::Debug::debug("Bad port $port (not numeric)");
  383.             next SET_COOKIE;
  384.             }
  385.             $found++ if $p eq $req_port;
  386.         }
  387.         unless ($found) {
  388.             LWP::Debug::debug("Request port ($req_port) not found in $port");
  389.             next SET_COOKIE;
  390.         }
  391.         } else {
  392.         $port = "_$req_port";
  393.         }
  394.     }
  395.     $self->set_cookie($version,$key,$val,$path,$domain,$port,$path_spec,$secure,$maxage,$discard, \%hash)
  396.         if $self->set_cookie_ok(\%orig_hash);
  397.     }
  398.  
  399.     $response;
  400. }
  401.  
  402. sub set_cookie_ok { 1 };
  403.  
  404. =item $cookie_jar->set_cookie($version, $key, $val, $path, $domain, $port, $path_spec, $secure, $maxage, $discard, \%rest)
  405.  
  406. The set_cookie() method updates the state of the $cookie_jar.  The
  407. $key, $val, $domain, $port and $path arguments are strings.  The
  408. $path_spec, $secure, $discard arguments are boolean values. The $maxage
  409. value is a number indicating number of seconds that this cookie will
  410. live.  A value <= 0 will delete this cookie.  %rest defines
  411. various other attributes like "Comment" and "CommentURL".
  412.  
  413. =cut
  414.  
  415. sub set_cookie
  416. {
  417.     my $self = shift;
  418.     my($version,
  419.        $key, $val, $path, $domain, $port,
  420.        $path_spec, $secure, $maxage, $discard, $rest) = @_;
  421.  
  422.     # path and key can not be empty (key can't start with '$')
  423.     return $self if !defined($path) || $path !~ m,^/, ||
  424.                 !defined($key)  || $key  !~ m,[^\$],;
  425.  
  426.     # ensure legal port
  427.     if (defined $port) {
  428.     return $self unless $port =~ /^_?\d+(?:,\d+)*$/;
  429.     }
  430.  
  431.     my $expires;
  432.     if (defined $maxage) {
  433.     if ($maxage <= 0) {
  434.         delete $self->{COOKIES}{$domain}{$path}{$key};
  435.         return $self;
  436.     }
  437.     $expires = time() + $maxage;
  438.     }
  439.     $version = 0 unless defined $version;
  440.  
  441.     my @array = ($version, $val,$port,
  442.          $path_spec,
  443.          $secure, $expires, $discard);
  444.     push(@array, {%$rest}) if defined($rest) && %$rest;
  445.     # trim off undefined values at end
  446.     pop(@array) while !defined $array[-1];
  447.  
  448.     $self->{COOKIES}{$domain}{$path}{$key} = \@array;
  449.     $self;
  450. }
  451.  
  452. =item $cookie_jar->save( [$file] );
  453.  
  454. This method file saves the state of the $cookie_jar to a file.
  455. The state can then be restored later using the load() method.  If a
  456. filename is not specified we will use the name specified during
  457. construction.  If the attribute I<ignore_discared> is set, then we
  458. will even save cookies that are marked to be discarded.
  459.  
  460. The default is to save a sequence of "Set-Cookie3" lines.
  461. "Set-Cookie3" is a proprietary LWP format, not known to be compatible
  462. with any browser.  The I<HTTP::Cookies::Netscape> sub-class can
  463. be used to save in a format compatible with Netscape.
  464.  
  465. =cut
  466.  
  467. sub save
  468. {
  469.     my $self = shift;
  470.     my $file = shift || $self->{'file'} || return;
  471.     local(*FILE);
  472.     open(FILE, ">$file") or die "Can't open $file: $!";
  473.     print FILE "#LWP-Cookies-1.0\n";
  474.     print FILE $self->as_string(!$self->{ignore_discard});
  475.     close(FILE);
  476.     1;
  477. }
  478.  
  479. =item $cookie_jar->load( [$file] );
  480.  
  481. This method reads the cookies from the file and adds them to the
  482. $cookie_jar.  The file must be in the format written by the save()
  483. method.
  484.  
  485. =cut
  486.  
  487. sub load
  488. {
  489.     my $self = shift;
  490.     my $file = shift || $self->{'file'} || return;
  491.     local(*FILE, $_);
  492.     local $/ = "\n";  # make sure we got standard record separator
  493.     open(FILE, $file) or return;
  494.     my $magic = <FILE>;
  495.     unless ($magic =~ /^\#LWP-Cookies-(\d+\.\d+)/) {
  496.     warn "$file does not seem to contain cookies";
  497.     return;
  498.     }
  499.     while (<FILE>) {
  500.     next unless s/^Set-Cookie3:\s*//;
  501.     chomp;
  502.     my $cookie;
  503.     for $cookie (split_header_words($_)) {
  504.         my($key,$val) = splice(@$cookie, 0, 2);
  505.         my %hash;
  506.         while (@$cookie) {
  507.         my $k = shift @$cookie;
  508.         my $v = shift @$cookie;
  509.         $hash{$k} = $v;
  510.         }
  511.         my $version   = delete $hash{version};
  512.         my $path      = delete $hash{path};
  513.         my $domain    = delete $hash{domain};
  514.         my $port      = delete $hash{port};
  515.         my $expires   = str2time(delete $hash{expires});
  516.  
  517.         my $path_spec = exists $hash{path_spec}; delete $hash{path_spec};
  518.         my $secure    = exists $hash{secure};    delete $hash{secure};
  519.         my $discard   = exists $hash{discard};   delete $hash{discard};
  520.  
  521.         my @array =    ($version,$val,$port,
  522.              $path_spec,$secure,$expires,$discard);
  523.         push(@array, \%hash) if %hash;
  524.         $self->{COOKIES}{$domain}{$path}{$key} = \@array;
  525.     }
  526.     }
  527.     close(FILE);
  528.     1;
  529. }
  530.  
  531. =item $cookie_jar->revert;
  532.  
  533. This method empties the $cookie_jar and re-loads the $cookie_jar
  534. from the last save file.
  535.  
  536. =cut
  537.  
  538. sub revert
  539. {
  540.     my $self = shift;
  541.     $self->clear->load;
  542.     $self;
  543. }
  544.  
  545. =item $cookie_jar->clear( [$domain, [$path, [$key] ] ]);
  546.  
  547. Invoking this method without arguments will empty the whole
  548. $cookie_jar.  If given a single argument only cookies belonging to
  549. that domain will be removed.  If given two arguments, cookies
  550. belonging to the specified path within that domain are removed.  If
  551. given three arguments, then the cookie with the specified key, path
  552. and domain is removed.
  553.  
  554. =cut
  555.  
  556. sub clear
  557. {
  558.     my $self = shift;
  559.     if (@_ == 0) {
  560.     $self->{COOKIES} = {};
  561.     } elsif (@_ == 1) {
  562.     delete $self->{COOKIES}{$_[0]};
  563.     } elsif (@_ == 2) {
  564.     delete $self->{COOKIES}{$_[0]}{$_[1]};
  565.     } elsif (@_ == 3) {
  566.     delete $self->{COOKIES}{$_[0]}{$_[1]}{$_[2]};
  567.     } else {
  568.     require Carp;
  569.         Carp::carp('Usage: $c->clear([domain [,path [,key]]])');
  570.     }
  571.     $self;
  572. }
  573.  
  574. =item $cookie_jar->clear_temporary_cookies( );
  575.  
  576. Discard all temporary cookies. Scans for all cookies in the jar 
  577. with either no expire field or a true C<discard> flag. To be 
  578. called when the user agent shuts down according to RFC 2965.
  579.  
  580. =cut
  581.  
  582. sub clear_temporary_cookies
  583. {
  584.     my($self) = @_;
  585.  
  586.     $self->scan(sub {
  587.         if($_[9] or        # "Discard" flag set
  588.            not $_[8]) {    # No expire field?
  589.             $_[8] = -1;            # Set the expire/max_age field
  590.             $self->set_cookie(@_); # Clear the cookie
  591.         }
  592.       });
  593. }
  594.  
  595. sub DESTROY
  596. {
  597.     my $self = shift;
  598.     $self->save if $self->{'autosave'};
  599. }
  600.  
  601.  
  602. =item $cookie_jar->scan( \&callback );
  603.  
  604. The argument is a subroutine that will be invoked for each cookie
  605. stored in the $cookie_jar.  The subroutine will be invoked with
  606. the following arguments:
  607.  
  608.   0  version
  609.   1  key
  610.   2  val
  611.   3  path
  612.   4  domain
  613.   5  port
  614.   6  path_spec
  615.   7  secure
  616.   8  expires
  617.   9  discard
  618.  10  hash
  619.  
  620. =cut
  621.  
  622. sub scan
  623. {
  624.     my($self, $cb) = @_;
  625.     my($domain,$path,$key);
  626.     for $domain (sort keys %{$self->{COOKIES}}) {
  627.     for $path (sort keys %{$self->{COOKIES}{$domain}}) {
  628.         for $key (sort keys %{$self->{COOKIES}{$domain}{$path}}) {
  629.         my($version,$val,$port,$path_spec,
  630.            $secure,$expires,$discard,$rest) =
  631.                @{$self->{COOKIES}{$domain}{$path}{$key}};
  632.         $rest = {} unless defined($rest);
  633.         &$cb($version,$key,$val,$path,$domain,$port,
  634.              $path_spec,$secure,$expires,$discard,$rest);
  635.         }
  636.     }
  637.     }
  638. }
  639.  
  640. =item $cookie_jar->as_string( [$skip_discard] );
  641.  
  642. The as_string() method will return the state of the $cookie_jar
  643. represented as a sequence of "Set-Cookie3" header lines separated by
  644. "\n".  If $skip_discard is TRUE, it will not return lines for
  645. cookies with the I<Discard> attribute.
  646.  
  647. =cut
  648.  
  649. sub as_string
  650. {
  651.     my($self, $skip_discard) = @_;
  652.     my @res;
  653.     $self->scan(sub {
  654.     my($version,$key,$val,$path,$domain,$port,
  655.        $path_spec,$secure,$expires,$discard,$rest) = @_;
  656.     return if $discard && $skip_discard;
  657.     my @h = ($key, $val);
  658.     push(@h, "path", $path);
  659.     push(@h, "domain" => $domain);
  660.     push(@h, "port" => $port) if defined $port;
  661.     push(@h, "path_spec" => undef) if $path_spec;
  662.     push(@h, "secure" => undef) if $secure;
  663.     push(@h, "expires" => HTTP::Date::time2isoz($expires)) if $expires;
  664.     push(@h, "discard" => undef) if $discard;
  665.     my $k;
  666.     for $k (sort keys %$rest) {
  667.         push(@h, $k, $rest->{$k});
  668.     }
  669.     push(@h, "version" => $version);
  670.     push(@res, "Set-Cookie3: " . join_header_words(\@h));
  671.     });
  672.     join("\n", @res, "");
  673. }
  674.  
  675. sub _host
  676. {
  677.     my($request, $url) = @_;
  678.     if (my $h = $request->header("Host")) {
  679.     $h =~ s/:\d+$//;  # might have a port as well
  680.     return $h;
  681.     }
  682.     return $url->host;
  683. }
  684.  
  685. sub _url_path
  686. {
  687.     my $url = shift;
  688.     my $path;
  689.     if($url->can('epath')) {
  690.        $path = $url->epath;    # URI::URL method
  691.     } else {
  692.        $path = $url->path;           # URI::_generic method
  693.     }
  694.     $path = "/" unless length $path;
  695.     $path;
  696. }
  697.  
  698. sub _normalize_path  # so that plain string compare can be used
  699. {
  700.     my $x;
  701.     $_[0] =~ s/%([0-9a-fA-F][0-9a-fA-F])/
  702.              $x = uc($1);
  703.                  $x eq "2F" || $x eq "25" ? "%$x" :
  704.                                             pack("C", hex($x));
  705.               /eg;
  706.     $_[0] =~ s/([\0-\x20\x7f-\xff])/sprintf("%%%02X",ord($1))/eg;
  707. }
  708.  
  709.  
  710.  
  711. =back
  712.  
  713. =head1 SUB CLASSES
  714.  
  715. We also provide a subclass called I<HTTP::Cookies::Netscape> which
  716. loads and saves Netscape compatible cookie files.  You
  717. should be able to have LWP share Netscape's cookies by constructing
  718. your $cookie_jar like this:
  719.  
  720.  $cookie_jar = HTTP::Cookies::Netscape->new(
  721.                    File     => "$ENV{HOME}/.netscape/cookies",
  722.                    AutoSave => 1,
  723.                );
  724.  
  725. Please note that the Netscape cookie file format is not able to store
  726. all the information available in the Set-Cookie2 headers, so you will
  727. probably loose some information if you save in this format.
  728.  
  729. =cut
  730.  
  731. package HTTP::Cookies::Netscape;
  732.  
  733. use vars qw(@ISA);
  734. @ISA=qw(HTTP::Cookies);
  735.  
  736. sub load
  737. {
  738.     my($self, $file) = @_;
  739.     $file ||= $self->{'file'} || return;
  740.     local(*FILE, $_);
  741.     local $/ = "\n";  # make sure we got standard record separator
  742.     my @cookies;
  743.     open(FILE, $file) || return;
  744.     my $magic = <FILE>;
  745.     unless ($magic =~ /^\# Netscape HTTP Cookie File/) {
  746.     warn "$file does not look like a netscape cookies file" if $^W;
  747.     close(FILE);
  748.     return;
  749.     }
  750.     my $now = time() - $EPOCH_OFFSET;
  751.     while (<FILE>) {
  752.     next if /^\s*\#/;
  753.     next if /^\s*$/;
  754.     chomp;
  755.     my($domain,$bool1,$path,$secure, $expires,$key,$val) = split(/\t/, $_);
  756.     $secure = ($secure eq "TRUE");
  757.     $self->set_cookie(undef,$key,$val,$path,$domain,undef,
  758.               0,$secure,$expires-$now, 0);
  759.     }
  760.     close(FILE);
  761.     1;
  762. }
  763.  
  764. sub save
  765. {
  766.     my($self, $file) = @_;
  767.     $file ||= $self->{'file'} || return;
  768.     local(*FILE, $_);
  769.     open(FILE, ">$file") || return;
  770.  
  771.     print FILE <<EOT;
  772. # Netscape HTTP Cookie File
  773. # http://www.netscape.com/newsref/std/cookie_spec.html
  774. # This is a generated file!  Do not edit.
  775.  
  776. EOT
  777.  
  778.     my $now = time - $EPOCH_OFFSET;
  779.     $self->scan(sub {
  780.     my($version,$key,$val,$path,$domain,$port,
  781.        $path_spec,$secure,$expires,$discard,$rest) = @_;
  782.     return if $discard && !$self->{ignore_discard};
  783.     $expires = $expires ? $expires - $EPOCH_OFFSET : 0;
  784.     return if $now > $expires;
  785.     $secure = $secure ? "TRUE" : "FALSE";
  786.     my $bool = $domain =~ /^\./ ? "TRUE" : "FALSE";
  787.     print FILE join("\t", $domain, $bool, $path, $secure, $expires, $key, $val), "\n";
  788.     });
  789.     close(FILE);
  790.     1;
  791. }
  792.  
  793. 1;
  794.  
  795. __END__
  796.  
  797. =head1 COPYRIGHT
  798.  
  799. Copyright 1997-1999 Gisle Aas
  800.  
  801. This library is free software; you can redistribute it and/or
  802. modify it under the same terms as Perl itself.
  803.  
  804. =cut
  805.